perm filename DATBAS.SAI[PIC,HE] blob
sn#430329 filedate 1979-04-04 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00020 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 ENTRY DCREPRO,DFNDPRO,DINIT,DDELET,DADD,DWRITE,DREM,DSTRIP,DREG,
C00010 00003 ! Procedure to find a property and its type given it's property name. If it
C00011 00004 ! Procedure to intialize the DATBAS. Specfically it intializes
C00013 00005 ! Procedure to delete an item and keep track of the items in use.
C00016 00006 ! Procedure to erase and or delete associations according
C00021 00007 ! Procedure to strip a region of its connections to other regions.
C00024 00008 ! Procedure to extract a region from the list and delete it
C00026 00009 ! Procedure to insert a region in REGLST before Region number POS.
C00028 00010 ! Procedure to input a leap data base from an asci file
C00037 00011 CKDFREL
C00040 00012 ! Procedure to output a leap data base to an asci file
C00050 00013 ! THIS IS THE OUTPUT LOOP
C00051 00014 [3] OUTPRINT(ITMVR2,2,0) ! DHUE
C00052 00015 [8] BEGIN "DCONTAINS"
C00055 00016 ! Procedure too output a list of rand regions without destroying
C00056 00017 ! Procedure to copy region number CREG from an asci file into CURREG
C00057 00018 ! Procedure to delete a data base from core
C00058 00019 simple internal PROCEDURE DRELFIL(STRING FILE)
C00059 00020 REQUIRE UNSTACK!DELIMITERS
C00060 ENDMK
C⊗;
ENTRY DCREPRO,DFNDPRO,DINIT,DDELET,DADD,DWRITE,DREM,DSTRIP,DREG,
DCOPROP,DREGFND,DEXTRACT,DCHEAD,DCOPREG,DINSERT,
DINBAS,DOUTBAS,DNEWBAS,DCOPBAS,DELBAS,DRELFIL,DRR,RRVAL;
BEGIN "DATBAS"
REQUIRE "BUFDEC" SOURCE!FILE;
COMMENT REQUIRE "EXTITM" SOURCE!FILE;
SOURCE!V(EXTITM);
INTERNAL RECORD!CLASS DRR(STRING ITEMVAR REG; INTEGER V1,V2);
INTERNAL RECORD!CLASS RRVAL(STRING ITEMVAR REG1,REG2; REAL V1);
REQUIRE "⊂⊃<>" DELIMITERS;
REDEFINE DERR=⊂USERERR(0,1,"DITEMS is about to exceed DMITEMS - operation aborted"&crlf&
"Delete some items"&crlf);⊃;
! Macro to keep count of items in use after creating a new function;
IFC STANFORD THENC DEFINE TENEX="FALSE";
ELSEC
DEFINE TENEX=⊂TRUE⊃;
ENDC
OWN INTEGER CAPITBRK;
INTERNAL INTEGER DITEMS; ! Number of items that are in use;
INTEGER DVERSION; ! Version number of this module;
INTERNAL INTEGER DMITEMS; ! Maximum number of items allowed to be allocated by this module;
INTERNAL INTEGER DFULL; ! Is zero if there are still more than one allowable allocatable item left
Otherwise it is set to -1;
DEFINE CKDFULL=⊂IF DFULL THEN RETURN⊃;
DEFINE CKDFIT(VAL)=⊂IF DFULL THEN RETURN(VAL)⊃;
DEFINE CKDFREL=⊂IF DFULL THEN BEGIN RELALL; RETURN END⊃;
DEFINE DPROLM=⊂70⊃; ! Maximum number of properties allowed;
! Property types where:
Type=1 String value
Type=2 2 packed integers
Type=3 3 packed integers
Type=4 Real
Type=5 Vector list array
Type=6 Integer array
Type=7 2 packed integer array
Type=8 region
Type=9 real array
Type=10 record!pointer drr(string itemvar reg, integer v1, v2)
Type=11 record!pointer rrval(string itemvar reg1,reg2, integer v1)
;
INTEGER DPRONM; ! Number of properties allocated;
INTERNAL LIST DPROLST; ! Allocated properties;
STRING ITEMVAR SIVTMP;
! Procedure used by DNEW and is not meant to be used by the user.;
simple internal ITEM PROCEDURE DTEMP(ITEMVAR ITMVR);
BEGIN "DTEMP"
DITEMS←DITEMS+1; ! One more item is being allocated;
IF DITEMS+1≥DMITEMS THEN BEGIN DFULL←-1; DERR; END;
RETURN(ITMVR);
END "DTEMP";
! Procedure to create a property item with the passed PNAM
and stores it it dprolst, with the type as a props(property)
If this operation cannot be done FLG is set to -1
and a item of TYPEIT(resull)=0 is retured.
If the property already exists that item will be returned and the type will not
be altered.;
simple internal ITEM PROCEDURE DCREPRO(STRING PNAM;INTEGER TYPE;REFERENCE INTEGER FLG);
BEGIN "DCREPRO"
STRING ITEMVAR NPROPERTY,OPROPERTY,ZILCHVAR;
INTEGER FLG,BRCHAR;
string str;
FLG←0;
str←scan(str←PNAM,CAPITBRK,BRCHAR);
if not equ(str,pnam) then PRINT("DCREPRO: Blank tab and crlf deleted from prop name",pnam,crlf);
if str=null then
begin
PRINT("DCREPRO: prop name of null not allowed");
flg←-1;
return(zilchvar);
end;
FOREACH OPROPERTY | OPROPERTY IN DPROLST DO
IF EQU(str,DATUM(OPROPERTY)) THEN RETURN(OPROPERTY);
IF ¬(0<TYPE<12) THEN
BEGIN
PRINT("DCREPRO: Illegal type for property",CRLF);
FLG←-1;
RETURN(ZILCHVAR);
END;
IF DFULL THEN BEGIN FLG←-1; RETURN(ZILCHVAR); END;
IF DPRONM≥DPROLM THEN
BEGIN
PRINT("DCREPRO: No more than ",dprolm," properties allowed",crlf);
FLG←-1;
RETURN(ZILCHVAR);
END;
DPRONM←DPRONM+1;
NPROPERTY←DNEW(STR);
PROPS(NPROPERTY)←TYPE;
PUT NPROPERTY IN DPROLST AFTER ∞;
RETURN(NPROPERTY);
END "DCREPRO";
! Procedure to find a property and its type given it's property name. If it
can't be found set FLG.;
simple internal ITEM PROCEDURE DFNDPRO(STRING PNAM;REFERENCE INTEGER TYPE,FLG);
BEGIN "DFNDPRO"
STRING ITEMVAR PROPERTY,ZILCHVAR;
INTEGER ERR,BRCHAR;
string str;
str←scan(str←PNAM,CAPITBRK,BRCHAR);
FOREACH PROPERTY | PROPERTY IN DPROLST DO
IF EQU(STR,DATUM(PROPERTY)) THEN
BEGIN
FLG←0;
TYPE←PROPS(PROPERTY);
RETURN(PROPERTY);
END;
FLG←-1;
TYPE←0;
RETURN(ZILCHVAR);
END "DFNDPRO";
! Procedure to intialize the DATBAS. Specfically it intializes
DITEMS to the number of declared items.;
simple internal PROCEDURE DINIT;
BEGIN "DINIT"
ITEMVAR ITMVR;
INTEGER FLG;
SETBREAK(CAPITBRK←GETBREAK,"",CRLF&TAB&" ","KIN");
DITEMS←(CVN(ITMVR←NEW(""))-1);
DELETE(ITMVR);
DMITEMS←100;
DVERSION←8;
IF DITEMS+1<DMITEMS THEN DFULL←0
ELSE BEGIN DFULL←-1; DERR; END;
DPRONM←0;
DMASK←DCREPRO("MASK",1,FLG);
DSIZE←DCREPRO("SIZE",4,FLG);
DHUE←DCREPRO("HUE",2,FLG);
DSAT←DCREPRO("SAT",2,FLG);
DINTENSITY←DCREPRO("INTENSITY",2,FLG);
DNEIGHBOR←DCREPRO("NEIGHBOR",8,FLG);
DINFRONT←DCREPRO("INFRONT",8,FLG);
DCONTAINS←DCREPRO("CONTAINS",8,FLG);
DANCESTORS←DCREPRO("ANCESTORS",8,FLG);
DDESCENDANTS←DCREPRO("DESCENDANTS",8,FLG);
DMDERIVE←DCREPRO("MDERIVE",3,FLG);
DPICSIZ←DCREPRO("PICSIZ",2,FLG);
DVECARR←DCREPRO("VECARR",5,FLG);
DRED←DCREPRO("RED",2,FLG);
DGREEN←DCREPRO("GREEN",2,FLG);
DBLUE←DCREPRO("BLUE",2,FLG);
DYINTENSITY←DCREPRO("YINTENSITY",2,FLG);
DIINTENSITY←DCREPRO("IINTENSITY",2,FLG);
DQINTENSITY←DCREPRO("QINTENSITY",2,FLG);
END "DINIT";
! Procedure to delete an item and keep track of the items in use.;
simple internal PROCEDURE DDELET(ITEMVAR ITMVR);
BEGIN "DDELET"
IF TYPEIT(ITMVR)≠0 THEN DELETE(ITMVR)
ELSE RETURN;
DITEMS←DITEMS-1;
IF DFULL AND DITEMS+1≤DMITEMS+1 THEN DFULL←0;
END "DDELET";
! Procedure to add an association to the data base.
if it exists, it is not done. Is to be used when
allowing multiple associations with the same property,
I.E.:
NEIGHBORS,LNEIGHBORS,DESCENDANTS,ETC.;
simple internal PROCEDURE DADD(ITEMVAR PROPERTY,OBJECT,VALUE);
IF ¬(PROPERTY⊗OBJECT≡VALUE) THEN
MAKE PROPERTY⊗OBJECT≡VALUE;
! Procedure to create or overwrite a property-association.
NOTE: That old value is deleted if an overwrite is done.
To be used on properties such as:
HUE,SAT,INTENSITY,ETC.;
simple internal PROCEDURE DWRITE(ITEMVAR PROPERTY,OBJECT,VALUE);
BEGIN "DWRITE"
ITEMVAR OVALUE;
IF PROPERTY⊗OBJECT≡BIND OVALUE THEN
BEGIN
ERASE PROPERTY⊗OBJECT≡OVALUE;
if props(property)≠8 then DDELET(OVALUE);
END;
MAKE PROPERTY⊗OBJECT≡VALUE;
END "DWRITE";
! PROCEDURE TO CONVERT A STRING TO A REGION;
simple internal ITEM PROCEDURE DCVSR(STRING NAME; LIST REGIONS; REFERENCE INTEGER FLAG);
BEGIN
STRING ITEMVAR SIVAR;
FLAG←-1;
FOREACH SIVAR | SIVAR IN REGIONS DO
IF EQU(DATUM(SIVAR),NAME) THEN BEGIN FLAG←0; RETURN(SIVAR) END;
RETURN(ANY);
END;
! Procedure to erase and or delete associations according
to the values of ERSW, DELSW, and INVSW.
Use this procedure at your own risk, i.e. some combinations
will do something that you don't want to happen.
VALUE OF ERSW RESULT
1 ERASE ALL PROPERTY⊗ANY≡ANY
2 ERASE ALL ANY⊗OBJECT≡ANY
3 ERASE ALL PROPERTY⊗OBJECT≡ANY
4 ERASE ALL ANY⊗ANY≡VALUE
5 ERASE ALL PROPERTY⊗ANY≡VALUE
6 ERASE ALL ANY⊗OBJECT≡VALUE
7 ERASE PROPERTY⊗OBJECT≡VALUE
VALUE OF DELSW RESULT TO TRIPLES THAT ARE ERASED
0 NOTHING
1 DELETE ALL PROPERTY'S
2 DELETE ALL OBJECT'S
3 DELETE ALL PROPERTY'S & OBJECT'S
4 DELETE ALL VALUE'S
5 DELETE ALL PROPERTY'S & VALUE'S
6 DELETE ALL OBJECT'S & VALUE'S
7 DELETE ALL PROPERTY'S & OBJECT'S & VALUE'S
i.e. bit encoded result 1 for property 2 for object and 4 for value
complementary values do useful things
VALUE OF INVSW RESULT
0 NOTHING EXTRA DONE
1 INVERSE RELATIONSHIPS ARE ALSO DONE THE
THE SAME WAY. AND IN THE CASE OF DESCENDANTS
AND ANCESTORS, THEY ARE CONSIDERED AS INVERSE
IN ADDITION.;
internal PROCEDURE DREM(ITEMVAR PROPERTY,OBJECT,VALUE; INTEGER ERSW,DELSW,INVSW);
BEGIN "DREM"
ITEMVAR PRO,OBJ,VAL;
! Delete procedure;
simple PROCEDURE DDREM(INTEGER DELSW);
BEGIN "DDREM"
ifc false thenc
IF DELSW<8 THEN CASE DELSW OF BEGIN
[1] DDELET(PRO);
[2] DDELET(OBJ);
[3] DDELET(VAL);
[4] BEGIN DDELET(PRO); DDELET(OBJ); END;
[5] BEGIN DDELET(PRO); DDELET(VAL); END;
[6] BEGIN DDELET(OBJ); DDELET(VAL); END;
[7] BEGIN DDELET(PRO); DDELET(OBJ); DDELET(VAL); END
END;
endc
if delsw land 1 then ddelet(pro);
if delsw land 2 then ddelet(obj);
if delsw land 4 then ddelet(val);
END "DDREM";
! Do opposite association;
simple PROCEDURE DOPP;
BEGIN "DOPP"
ITEMVAR TPRO;
IF PRO⊗VAL≡OBJ THEN
BEGIN
ERASE PRO⊗VAL≡OBJ;
OBJ↔VAL;
DDREM(DELSW);
OBJ↔VAL;
END;
IF PRO=DDESCENDANTS OR PRO=DANCESTORS THEN
BEGIN
IF PRO=DDESCENDANTS THEN TPRO←DANCESTORS
ELSE TPRO←DDESCENDANTS;
IF TPRO⊗VAL≡OBJ THEN
BEGIN
ERASE TPRO⊗OBJ≡VAL;
OBJ↔VAL;
DDREM(DELSW);
OBJ↔VAL;
END;
END;
END "DOPP";
simple PROCEDURE ERASE!OPP!REM;
BEGIN
ERASE PRO⊗OBJ≡VAL;
IF INVSW THEN DOPP;
DDREM(DELSW);
END;
if ersw land 1 then pro←property;
if ersw land 2 then obj←object;
if ersw land 4 then val←value;
IF ERSW<8 THEN CASE ERSW OF BEGIN
[1] FOREACH OBJ,VAL|PRO⊗OBJ≡VAL DO ERASE!OPP!REM;
[2] FOREACH PRO,VAL|PRO⊗OBJ≡VAL DO ERASE!OPP!REM;
[3] FOREACH VAL|PRO⊗OBJ≡VAL DO ERASE!OPP!REM;
[4] FOREACH PRO,OBJ|PRO⊗OBJ≡VAL DO ERASE!OPP!REM;
[5] FOREACH OBJ|PRO⊗OBJ≡VAL DO ERASE!OPP!REM;
[6] FOREACH PRO|PRO⊗OBJ≡VAL DO ERASE!OPP!REM;
[7] IF PRO⊗OBJ≡VAL THEN ERASE!OPP!REM
END;
END "DREM";
! Procedure to strip a region of its connections to other regions.
(So that it can be transfered to another base.);
simple internal ITEM PROCEDURE DSTRIP(STRING ITEMVAR REGION);
BEGIN "DSTRIP"
STRING ITEMVAR PROPERTY,ZILCHR;
INTEGER K;
FOR K←1 THRU DPRONM DO
IF PROPS(DPROLST[K])=8 THEN
BEGIN
PROPERTY←DPROLST[K];
DREM(PROPERTY,REGION,ZILCHR,3,0,0);
DREM(PROPERTY,ZILCHR,REGION,5,0,0);
END;
RETURN(REGION);
END "DSTRIP";
! Procedure to Delete a region;
simple internal PROCEDURE DREG(STRING ITEMVAR REGION);
BEGIN "DREG"
ITEMVAR PROPERTY,ZILCHR;
DSTRIP(REGION);
FOREACH PROPERTY | PROPERTY IN DPROLST DO
DREM(PROPERTY,REGION,ZILCHR,3,4,0); ! delete values;
DDELET(REGION);
END "DREG";
! Procedure to copy a property from one region to another;
simple internal PROCEDURE DCOPROP(ITEMVAR PROPERTY;STRING ITEMVAR FROMREG,TOREG);
BEGIN "DCOPROP"
IFC NOT TENEX THENC
INTEGER ITEMVAR INTVAR;
STRING ITEMVAR STRVAR;
INTEGER ARRAY ITEMVAR ARRVAR;
real ARRAY ITEMVAR RARRVAR;
REAL ITEMVAR RELVAR;
ITEMVAR ITMVR1;
simple ITEM PROCEDURE DCRE(ITEMVAR ITMVR);
CASE TYPEIT(ITMVR) OF BEGIN
[3] RETURN(DNEW(DATUM(STRVAR←ITMVR)));
[4] RETURN(DNEW(DATUM(RELVAR←ITMVR)));
[5] RETURN(DNEW(DATUM(INTVAR←ITMVR)));
[24] RETURN(DNEW(DATUM(RARRVAR←ITMVR)));
[25] RETURN(DNEW(DATUM(ARRVAR←ITMVR)))
END;
IF PROPERTY⊗FROMREG≡BIND ITMVR1 THEN
CKDFULL
ELSE DWRITE(PROPERTY,TOREG,DCRE(ITMVR1));
ENDC
END "DCOPROP";
! Procedure to find a region in a base and sets err to one
if it can't find it and returns a cludged answer;
simple internal ITEM PROCEDURE DREGFND(INTEGER REG;REFERENCE LIST REGLST;REFERENCE INTEGER ERR);
BEGIN "DREGFND"
ERR←0;
IF 0≤REG<LENGTH(REGLST) THEN RETURN(REGLST[REG+1]);
ERR←1; Return(ANY);
END "DREGFND";
! Procedure to extract a region from the list and delete it;
simple internal PROCEDURE DEXTRACT(STRING ITEMVAR REGION; REFERENCE LIST REGLST);
BEGIN "DEXTRACT"
INTEGER REG,I,TEMP;
REG←PROPS(REGION);
REMOVE REGION FROM REGLST;
DREG(REGION);
FOR I←REG THRU LENGTH(REGLST) DO
PROPS(REGLST[I])←I-1;
END "DEXTRACT";
! Procedure to create a header region for a base.
(Region 0);
simple internal ITEM PROCEDURE DCHEAD(STRING BASENAME;INTEGER ROWZ,COLMZ);
BEGIN "DCHEAD"
STRING ITEMVAR REGION;
CKDFIT(REGION);
PROPS(REGION←DNEW(BASENAME))←0;
CKDFIT(REGION);
MAKE DPICSIZ⊗REGION≡DNEW((ROWZ LSH 18)+COLMZ);
RETURN(REGION);
END "DCHEAD";
! Procedure to return an "stripped" (see DSTRIP) copy of a
region in a new region.;
simple internal ITEM PROCEDURE DCOPREG(STRING ITEMVAR REGION);
BEGIN "DCOPREG"
IFC NOT TENEX THENC
STRING ITEMVAR NEWREG;
INTEGER K;
ITEMVAR PROPERTY;
CKDFIT(NEWREG);
NEWREG←DNEW(DATUM(REGION));
FOR K←1 THRU DPRONM DO
IF PROPS(DPROLST[K])≠8 THEN
BEGIN
PROPERTY←DPROLST[K];
CKDFIT(NEWREG)
ELSE DCOPROP(PROPERTY,REGION,NEWREG);
END;
RETURN(NEWREG);
ELSEC RETURN(REGION) ENDC
END "DCOPREG";
! Procedure to insert a region in REGLST before Region number POS.
Thus all regions with props≥POS will be incremented by 1 and the
region will be found in REGLST with the props of POS before the
the region with next higher props. Otherwise it will be found
at the end of the list. If you want the region to be placed at
the end of the list with props of 1 higher than the biggest props
in the list set POS to -1;
simple internal PROCEDURE DINSERT(STRING ITEMVAR REGION;REFERENCE LIST REGLST;INTEGER POS);
BEGIN "DINSERT"
INTEGER LOWEST,ERR;
STRING ITEMVAR REG;
IF POS<0 OR POS≥LENGTH(REGLST) THEN
BEGIN
PROPS(REGION)←LENGTH(REGLST);
PUT REGION IN REGLST AFTER ∞;
END
ELSE
BEGIN
PROPS(REGION)←POS;
FOREACH REG | REG IN REGLST DO IF PROPS(REG)≥POS THEN
PROPS(REG)←PROPS(REG)+1;
PUT REGION IN REGLST BEFORE DREGFND(POS,REGLST,0);
END;
END "DINSERT";
! Procedure to input a leap data base from an asci file;
internal PROCEDURE DINBAS(REFERENCE STRING BASFIL; REFERENCE LIST REGLST);
BEGIN "DINBAS"
INTEGER CHAN,BRCHAR,EOF,FLG,I,BRK1,BRK2,BRK3,BRK4,BRK5,BRK6,BRK7,BRK8,TYPE,REGNUM,COLMZ,ROWZ,DUM,lastun;
INTEGER ITMNUM,MODIFIER;
STRING STR1,STR2,SDUM;
STRING ITEMVAR CURREG,TMPVAR,REG,PROPERTY;
ITEMVAR XITMV;
RECORD!POINTER(DRR) RPIV;
RECORD!POINTER(RRVAL) RRREC;
! Procedure to release all breaktables and channels opened by this procedure;
simple PROCEDURE RELALL;
BEGIN "RELALL"
RELBREAK(BRK1);
RELBREAK(BRK2);
RELBREAK(BRK3);
RELBREAK(BRK4);
RELBREAK(BRK5);
RELBREAK(BRK6);
RELBREAK(BRK7);
RELBREAK(BRK8);
RELEASE(CHAN);
END "RELALL";
! Procedure to input an association according to the type
as defined for DPROTYP. ;
PROCEDURE INMAKE(ITEMVAR PROPERTY;STRING ITEMVAR CURREG;INTEGER TYPE);
BEGIN
INTEGER SIZE,K,NUM1,NUM2,NUM3;
CASE TYPE OF
BEGIN
[1] BEGIN "STRING"
! String with no blanks;
DWRITE(PROPERTY,CURREG,XITMV←DNEW(INPUT(CHAN,BRK4)));
END "STRING";
[2] BEGIN "2 INT"
NUM1←INTIN(CHAN);
INPUT(CHAN,BRK3);
Dadd(PROPERTY,CURREG,XITMV←DNEW((NUM1 LSH 18)+rhalf(<INTIN(CHAN)>)));
INPUT(CHAN,BRK3);
END "2 INT";
[3] BEGIN "3 INT"
SDUM←INPUT(CHAN,BRK2);
NUM1←INTSCAN(SDUM,BRCHAR);
NUM2←INTSCAN(SDUM,BRCHAR);
NUM3←INTSCAN(SDUM,BRCHAR);
DWRITE(PROPERTY,CURREG,XITMV←DNEW(THRSTUFF(NUM1,NUM2,NUM3)));
END "3 INT";
[4] BEGIN "REAL"
DWRITE(PROPERTY,CURREG,XITMV←DNEW(REALIN(CHAN)));
END "REAL";
[5] BEGIN "VECTOR ARRAY"
DUM←INTIN(CHAN)+2;
IF DUM≠2 THEN
BEGIN
SAFE INTEGER ARRAY VECS[1:DUM];
FOR I←1 THRU DUM DO VECS[I]←(INTIN(CHAN) LSH 18)+INTIN(CHAN);
DWRITE(PROPERTY,CURREG,XITMV←DNEW(VECS));
END;
END "VECTOR ARRAY";
[6] BEGIN "ARRAY"
SIZE←INTIN(CHAN);
BEGIN SAFE INTEGER ARRAY DVECS[1:SIZE];
FOR K←1 THRU SIZE DO DVECS[K]←INTIN(CHAN);
DWRITE(PROPERTY,CURREG,XITMV←DNEW(DVECS));
END;
END "ARRAY";
[7] BEGIN "2 PACKED ARRAY"
SIZE←INTIN(CHAN);
BEGIN SAFE INTEGER ARRAY DVECS[1:SIZE];
FOR K←1 THRU SIZE DO
BEGIN
NUM1←INTIN(CHAN) LSH 18;
NUM2←RHALF(<INTIN(CHAN)>);
DVECS[K]←NUM1+NUM2;
END;
DWRITE(PROPERTY,CURREG,XITMV←DNEW(DVECS));
END;
END "2 PACKED ARRAY";
[8] BEGIN "REGION"
SDUM←INPUT(CHAN,BRK2);
DUM←INTSCAN(SDUM,BRCHAR);
WHILE BRCHAR≠-1 DO
BEGIN
DADD(PROPERTY,CURREG,REGLST[DUM+1]);
DUM←INTSCAN(SDUM,BRCHAR);
END;
END "REGION";
[9] begin "real array"
integer size2,i;
size←intin(chan);
size2←intin(chan);
begin safe real array rarr[1:size,1:size2];
for i←1 thru size do
for k←1 thru size2 do
rarr[i,k]←realin(chan);
dwrite(property,curreg,XITMV←DNEW(rarr));
end;
end "real array";
[10] BEGIN "RECORD TYPE"
RPIV←NEW!RECORD(DRR);
SDUM←INPUT(CHAN,BRK2);
DRR:REG[RPIV]←REGLST[INTSCAN(SDUM,BRCHAR)+1];
DRR:V1[RPIV]←INTSCAN(SDUM,BRCHAR);
DRR:V2[RPIV]←INTSCAN(SDUM,BRCHAR);
DADD(PROPERTY,CURREG,XITMV←DNEW(RPIV));
END "RECORD TYPE";
[11] BEGIN "RECORD TYPE 2"
RRREC←NEW!RECORD(RRVAL);
SDUM←INPUT(CHAN,BRK2);
RRVAL:REG1[RRREC]←REGLST[INTSCAN(SDUM,BRCHAR)+1];
RRVAL:REG2[RRREC]←REGLST[INTSCAN(SDUM,BRCHAR)+1];
RRVAL:V1[RRREC]←REALSCAN(SDUM,BRCHAR);
DADD(PROPERTY,CURREG,XITMV←DNEW(RRREC));
END "RECORD TYPE 2"
END;
IF MODIFIER THEN PROPS(XITMV)←MODIFIER;
END;
CKDFULL;
READ(CHAN←-1,0,BRCHAR,EOF,BASFIL,"INF");
SETBREAK(BRK1←GETBREAK,")]0123456789"&CRLF&'40&TAB&FORMFEED,NULL,"XNR");
SETBREAK(BRK2←GETBREAK,")[="&CR,NULL,"IN");
SETBREAK(BRK3←GETBREAK,CR&",",LF&TAB,"IN");
SETBREAK(BRK4←GETBREAK,CR,LF&TAB&" ","IN");
SETBREAK(BRK5←GETBREAK,CR,CR,"IN");
SETBREAK(BRK6←GETBREAK," =["&CR&TAB," =["&CR&TAB,"IN");
SETBREAK(BRK7←GETBREAK,"<",NULL,"XRN"); ! BREAK TABLES TO GET THE MODIFIERS IN;
SETBREAK(BRK8←GETBREAK,">",NULL,"INS");
! Remember number of items that are around before DINBAS;
ITMNUM←DITEMS;
! SETS UP REGLST;
IF INTIN(CHAN) THEN
BEGIN
PRINT("Not a legal base file",crlf);
RELALL;
RETURN;
END;
SCAN(SDUM←INPUT(CHAN,BRK5),BRK1,BRCHAR);
TMPVAR←DNEW(SDUM);
PUT TMPVAR IN REGLST AFTER ∞;
PROPS(TMPVAR)←0;
REGNUM←INTIN(CHAN);
FOR I←1 THRU REGNUM DO CKDFREL
ELSE PUT DNEW(NULL) IN REGLST AFTER ∞;
! Check for VERSION NUMBER of file in REGION 0;
INPUT(CHAN,BRK1);
IF BRCHAR≠"[" THEN SDUM←INPUT(CHAN,BRK2);
IF BRCHAR="=" AND EQU(SDUM,"VERSION NUMBER") THEN
BEGIN
IFC FALSE THENC VERS← ENDC INTIN(CHAN);
INPUT(CHAN,BRK1);
IF BRCHAR≠"[" THEN SDUM←INPUT(CHAN,BRK2);
END
IFC FALSE THENC ELSE VERS←0 ENDC;
IFC FALSE THENC
! If DINBAS is not updated for the lastest version of the data base
then tell the user;
IF VERS>DVERSION THEN
BEGIN
PRINT("DINBAS: Cannot handle file with VERSION= ",VERS,"; load new ""DATBAS""!",CRLF);
RELALL;
RETURN;
END;
ENDC
CKDFREL;
! Check for Picture size;
IF BRCHAR="=" AND EQU(SDUM,"ROWS BY COLUMNS") THEN
BEGIN
ROWZ←INTIN(CHAN);
COLMZ←INTIN(CHAN);
MAKE DPICSIZ⊗TMPVAR≡DNEW((ROWZ LSH 18)+COLMZ);
INPUT(CHAN,BRK1);
IF BRCHAR≠"[" THEN SDUM←INPUT(CHAN,BRK2);
END
ELSE MAKE DPICSIZ⊗TMPVAR≡DNEW((600 LSH 18)+820);
! Read any properties;
IF BRCHAR="=" AND EQU(SDUM,"PROPERTIES") THEN
BEGIN
INPUT(CHAN,BRK1);
SDUM←INPUT(CHAN,BRK6);
WHILE ¬EQU(SDUM,"TERMINATION") DO
BEGIN
CKDFREL
ELSE CURREG←DCREPRO(SDUM,INTIN(CHAN),FLG);
INPUT(CHAN,BRK1);
SDUM←INPUT(CHAN,BRK6);
END;
INPUT(CHAN,BRK1);
IF BRCHAR≠"[" THEN SDUM←INPUT(CHAN,BRK2);
END;
! THIS IS THE INPUT LOOP;
FOREACH CURREG|CURREG IN REGLST DO
BEGIN
IF CURREG≠TMPVAR THEN
BEGIN
PROPS(CURREG)←INTIN(CHAN);
SCAN(SDUM←INPUT(CHAN,BRK5),BRK1,BRCHAR);
DATUM(CURREG)←SDUM;
CKDFREL;
INMAKE(DVECARR,CURREG,5);
INPUT(CHAN,BRK1);
SDUM←INPUT(CHAN,BRK2);
END;
lastun←1;
WHILE BRCHAR="=" DO
BEGIN
SZILCH←SDUM;
FOR I←lastun THRU DPRONM, 1 thru dpronm
DO IF EQU(SZILCH,DATUM(SIVTMP←DPROLST[I])) THEN begin lastun←i; DONE; end;
CKDFREL;
SZILCH←INPUT(CHAN,BRK7); ! LOOKING FOR MODIFIERS IN <>;
IF EQU(SZILCH[1 FOR 1],"<") THEN BEGIN
SZILCH←INPUT(CHAN,BRK8);
IF EQU(SZILCH,"GREATER") THEN MODIFIER←2
ELSE IF EQU(SZILCH,"LESS") THEN MODIFIER←1
ELSE IF EQU(SZILCH,"APPROX") THEN MODIFIER←4
ELSE MODIFIER←0;
END
ELSE MODIFIER←0;
IF I≤dpronm THEN
BEGIN
PROPERTY←dprolst[i];
type←props(property);
INMAKE(PROPERTY,CURREG,TYPE);
END
ELSE PRINT("Something is wrong in your ASCII input file",sdum,crlf);
INPUT(CHAN,BRK1);
SDUM←INPUT(CHAN,BRK2);
END;
PRINT("+");
END;
RELALL;
PRINT(CRLF,DITEMS-ITMNUM," Items allocated",CRLF);
END "DINBAS";
! Procedure to output a leap data base to an asci file;
internal PROCEDURE DOUTBAS(REFERENCE STRING BASFIL; REFERENCE LIST REGLST);
BEGIN "DOUTBAS"
INTEGER ODUM,CHAN,BRCHAR,EOF,FLG,I,COUNT,NUMOUT,TAB1,TAB2,TAB3,TAB4,J,K,R;
integer szavit;
INTEGER LSTLNGTH;
STRING STR,TABS,TMPFILE,dstr,d1str;
STRING ITEMVAR CURREG,TMPVAR,STRVAR;
RECORD!POINTER(DRR) ITEMVAR RPIV;
RECORD!POINTER(DRR) DRREC;
RECORD!POINTER(RRVAL) ITEMVAR RRVIV;
RECORD!POINTER(RRVAL) RRREC;
INTEGER ITEMVAR INTVAR;
REAL ITEMVAR RELVAR;
SAFE INTEGER ARRAY ITEMVAR ARRVAR;
ITEMVAR ITMVR1,ITMVR2;
boolean anypro,FOUND;
DEFINE REGNUM(NUM)=⊂"[",NUM,"]"⊃;
DEFINE BROCKET(NUM1,NUM2,NUM3,NUM4)=⊂"<",NUM1,"*",NUM2,"><",
NUM3,"*",NUM4,">"⊃;
! PROCEDURE TO GENERATE MODIFIER IF ANY;
simple STRING PROCEDURE PRIN!MODIF;
IF PROPS(ITMVR1)=8 THEN RETURN(NULL)
ELSE RETURN(CASE PROPS(ITMVR2) OF (NULL,"<LESS>","<GREATER>",NULL,"<APPROX>"));
! Procedure to output an association according to type
as defined for DPROTYP. ;
PROCEDURE OUTPRINT(ITEMVAR VAL;INTEGER TYPE,DIVD);
CASE TYPE OF
BEGIN
[1] BEGIN
CPRINT(CHAN," ",DATUM(STRVAR←VAL));
END;
[2] BEGIN "2 INT"
STR←CVS(DUM←SLHALF(<DATUM(INTVAR←VAL)>));
CPRINT(CHAN,STR,TABS[1 TO TAB4-LENGTH(SDUM)-LENGTH(STR)-1]);
if divd then CPRINT(chan,"(",cvf(dum/divd)," )");
STR←CVS(DUM←SRHALF(<DATUM(INTVAR)>));
CPRINT(CHAN,TAB,", STDEV=",STR,TABS[1 TO TAB4-6-LENGTH(STR)]);
if divd then CPRINT(chan,"(",cvf(dum/divd)," )");
END "2 INT";
[3] BEGIN "3 INT"
DUM←DATUM(INTVAR←VAL);
CPRINT(CHAN,TAB," ",SUN1ST(DUM),TAB," ",SUN2ND(DUM)," ",TAB," ",SUN3RD(DUM));
END "3 INT";
[4] BEGIN "REAL"
CPRINT(CHAN,CVF(DATUM(RELVAR←VAL)));
END "REAL";
[5] BEGIN "VECTOR ARRAY"
INTEGER ARRAY ITEMVAR ARRVAR;
ARRVAR←VAL;
CPRINT(CHAN,TAB,(DUM←ARRINFO(DATUM(ARRVAR),0))-2,TAB,BROCKET(SLHALF(<DATUM(ARRVAR)[1]>),
SRHALF(<DATUM(ARRVAR)[1]>),SLHALF(<DATUM(ARRVAR)[2]>),SRHALF(<DATUM(ARRVAR)[2]>)),CRLF);
STR←CVS(SLHALF(<DATUM(ARRVAR)[3]>));
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[3]>));
CPRINT(CHAN,TAB,"(",TABS[1 TO TAB1-LENGTH(STR)],STR,",",SDUM);
NUMOUT←1;
FOR I←4 THRU DUM DO
BEGIN
NUMOUT←NUMOUT+1;
STR←CVS(SLHALF(<DATUM(ARRVAR)[I]>));
IF NUMOUT>6 THEN BEGIN NUMOUT←1; CPRINT(CHAN,CRLF,TAB,TABS[1 TO TAB2-LENGTH(STR)]) END
ELSE CPRINT(CHAN,TABS[1 TO TAB3-LENGTH(SDUM)-LENGTH(STR)]);
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[I]>));
CPRINT(CHAN,STR,",",SDUM);
END;
CPRINT(CHAN," )");
END "VECTOR ARRAY";
[6] BEGIN "ARRAY"
INTEGER ARRAY ITEMVAR ARRVAR;
INTEGER K,LN;
ARRVAR←VAL;
LN←ARRINFO(DATUM(ARRVAR),0);
str←cvs(datum(arrvar)[1]);
CPRINT(chan,tab,ln,crlf,tab,tabs[3 to tab3-length(str)],"( ",str);
NUMOUT←1;
FOR K←2 THRU LN DO
BEGIN
NUMOUT←NUMOUT+1;
STR←CVS(DATUM(ARRVAR)[K]);
IF NUMOUT>6 THEN BEGIN NUMOUT←1; CPRINT(CHAN,CRLF,TAB,TABS[1 TO TAB2-LENGTH(STR)]) END
ELSE CPRINT(CHAN,TABS[1 TO TAB3-LENGTH(STR)]);
CPRINT(CHAN,STR);
END;
CPRINT(CHAN," )");
END "ARRAY";
[7] BEGIN "2 PACKED ARRAY"
INTEGER ARRAY ITEMVAR ARRVAR;
ARRVAR←VAL;
CPRINT(CHAN,TAB,(DUM←ARRINFO(DATUM(ARRVAR),0)),CRLF);
IF DUM>0 THEN BEGIN
STR←CVS(SLHALF(<DATUM(ARRVAR)[1]>));
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[1]>));
CPRINT(CHAN,TAB,"(",TABS[1 TO TAB1-LENGTH(STR)],STR,",",SDUM);
NUMOUT←1;
FOR I←2 THRU DUM DO
BEGIN
NUMOUT←NUMOUT+1;
STR←CVS(SLHALF(<DATUM(ARRVAR)[I]>));
IF NUMOUT>6 THEN BEGIN NUMOUT←1; CPRINT(CHAN,CRLF,TAB,TABS[1 TO TAB2-LENGTH(STR)]) END
ELSE CPRINT(CHAN,TABS[1 TO TAB3-LENGTH(SDUM)-LENGTH(STR)]);
SDUM←CVS(SRHALF(<DATUM(ARRVAR)[I]>));
CPRINT(CHAN,STR,",",SDUM);
END;
CPRINT(CHAN," )");
END;
END "2 PACKED ARRAY";
[8] BEGIN "REGION"
FOREACH STRVAR | VAL⊗CURREG≡STRVAR DO
IF (strvar IN REGLST) THEN
CPRINT(CHAN," ",PROPS(strvar));
END "REGION";
[9] begin "real array"
real array itemvar raiv;
integer i,j,size1,size2;
raiv←itmvr2;
size1←arrinfo(datum(raiv),2);
size2←arrinfo(datum(raiv),4);
CPRINT(chan,TAB,size1,TAB,size2);
for i←1 thru size1 do
begin
CPRINT(chan,crlf,TAB);
for j←1 thru size2 do
CPRINT(chan,cvf(datum(raiv)[i,j]),TAB);
end;
end "real array";
[10] BEGIN "RECORD TYPE"
RPIV←VAL;
DRREC←DATUM(RPIV);
CPRINT(CHAN,TAB,"REG: ",PROPS(DRR:REG[DRREC])," VAL: ",DRR:V1[DRREC]," VAL: ",DRR:V2[DRREC]);
END "RECORD TYPE";
[11] BEGIN "RECORD TYPE 2"
RRVIV←VAL;
RRREC←DATUM(RRVIV);
CPRINT(CHAN,TAB,"REG1: ",PROPS(RRVAL:REG1[RRREC]),
" REG2: ",PROPS(RRVAL:REG2[RRREC]),
" VAL: ",CVF(RRVAL:V1[RRREC]));
END "RECORD TYPE 2"
END;
! PROGRAM STARTS HERE;
TAB1←4; TAB2←TAB1+1; TAB3←9; TAB4←22;
TABS←" ";
WHILE BASFIL=NULL DO SPRMPT("DOUTBAS: Output file name:",BASFIL);
SDUM←GETDEV(BASFIL,"INF");
WRITE(CHAN←-1,0,BRCHAR,EOF,IFC TENEX THENC BASFIL ELSEC TMPFILE←"DTBS"&CVS(DUM←CALL(0,"PJOB")) ENDC,"INF");
TMPVAR←REGLST[1];
CPRINT(CHAN,REGNUM(0),TAB,DATUM(TMPVAR),CRLF);
! Tell how many regions there are;
CPRINT(CHAN,TAB,"NUMBER OF REGIONS=",LENGTH(REGLST)-1);
! Tell what the version number of the file is;
IFC FALSE THENC
CPRINT(CHAN,CRLF,TAB,"VERSION NUMBER=",DVERSION);
ENDC
! Put out the DSIZE of the picture;
IF DPICSIZ⊗TMPVAR≡BIND INTVAR THEN
BEGIN
ODUM←DATUM(INTVAR);
CPRINT(CHAN,CRLF,TAB,"ROWS BY COLUMNS= ",LHALF(ODUM)," BY ",RHALF(ODUM));
END
ELSE CPRINT(CHAN,CRLF,TAB,"ROWS BY COLUMNS= 600 BY 820");
IF DPRONM>19 THEN
BEGIN
anypro←false;
FOR I←20 THRU DPRONM DO
BEGIN
FOUND←FALSE;
FOREACH STRVAR | STRVAR IN REGLST DO IF (DPROLST[I]⊗STRVAR≡BIND ITMVR1) THEN BEGIN FOUND←TRUE; DONE; END;
IF FOUND THEN
BEGIN
IF ¬ANYPRO THEN
BEGIN
CPRINT(CHAN,CRLF,TAB,"PROPERTIES=");
ANYPRO←TRUE;
END;
CPRINT(CHAN,CRLF,TAB," ",DATUM(SIVTMP←DPROLST[I]),TAB,PROPS(DPROLST[I]));
END;
END;
IF ANYPRO THEN CPRINT(CHAN,CRLF,TAB," TERMINATION");
END;
! THIS IS THE OUTPUT LOOP;
FOREACH CURREG | CURREG IN REGLST DO
BEGIN "OUTLOOP"
IF CURREG≠TMPVAR THEN
BEGIN
CPRINT(CHAN,REGNUM(PROPS(CURREG)),TAB,DATUM(CURREG),CRLF);
IF DVECARR ⊗ CURREG ≡BIND ARRVAR
THEN OUTPRINT(ARRVAR,5,0)
ELSE CPRINT(CHAN,TAB,"0");
END;
FOR K←1 THRU DPRONM DO IF (ITMVR1←DPROLST[K])⊗CURREG≡BIND ITMVR2 AND (ITMVR1≠DVECARR) THEN
BEGIN
d1str←SDUM←DATUM(SIVTMP←ITMVR1);
IF ¬(ITMVR1=DPICSIZ AND TMPVAR=CURREG) THEN CPRINT(CHAN,CRLF,TAB,SDUM,"=",PRIN!MODIF);
IF 1≤K≤19 THEN
CASE K OF BEGIN
[1] OUTPRINT(ITMVR2,1,0); ! DMASK picture files;
[2] OUTPRINT(ITMVR2,4,0);! DSIZE;
[3] OUTPRINT(ITMVR2,2,0); ! DHUE;
[4] OUTPRINT(ITMVR2,2,2↑10-1); ! DSAT;
[5] OUTPRINT(ITMVR2,2,10);
[6] BEGIN "DNEIGHBOR"
OUTPRINT(DNEIGHBOR,8,0);
END;
[7] BEGIN "DINFRONT"
OUTPRINT(DINFRONT,8,0);
END;
[8] BEGIN "DCONTAINS"
OUTPRINT(DCONTAINS,8,0);
END;
[9] BEGIN "DANCESTORS"
OUTPRINT(DANCESTORS,8,0);
END;
[10] BEGIN "DDESCENDANTS"
OUTPRINT(DDESCENDANTS,8,0);
END;
[11] BEGIN "DMDERIVE"
INTVAR←ITMVR2;
DUM←DATUM(INTVAR);
CPRINT(CHAN,TAB,"PARM: ",UN1ST(DUM),TAB,"UPTHR: ",UN2ND(DUM),TAB,"LWTHR: ",UN3RD(DUM),CRLF);
END;
[12] IF CURREG≠TMPVAR THEN OUTPRINT(ITMVR2,2,0); ! DPICSIZ, 13 IS VECTARR, ALREADY DONE;
[14] OUTPRINT(ITMVR2,2,10); ! DRED;
[15] OUTPRINT(ITMVR2,2,10); ! DGREEN;
[16] OUTPRINT(ITMVR2,2,10); ! DBLUE;
[17] OUTPRINT(ITMVR2,2,10); ! DYINTENSITY;
[18] OUTPRINT(ITMVR2,2,10); ! DIINTENSITY;
[19] OUTPRINT(ITMVR2,2,10) ! DQINTENSITY;
END
ELSE IF K>19 THEN
BEGIN
IF ¬(ITMVR1 IN DPROLST)
then print("Undeclared property in association - ignored",crlf)
else if (szavit←PROPS(itmvr1))=8
then outprint(itmvr1,8,0)
else begin
dstr←"";
foreach itmvr2 | itmvr1⊗curreg≡itmvr2
do begin
CPRINT(chan,dstr,IF LENGTH(DSTR) THEN PRIN!MODIF ELSE NULL);
OUTPRINT(ITMVR2,szavit,0);
dstr←crlf&tab&d1str&"=";
end;
END;
END;
END;
CPRINT(CHAN,CRLF,CRLF);
PRINT("#");
END "OUTLOOP";
RELEASE(CHAN);
IFCR NOT TENEX THENC
OPEN(CHAN←DGETCHAN,"DSK",0,4,0,0,BRCHAR,EOF);
LOOKUP(CHAN,BASFIL,FLG);
IF ¬FLG THEN RENAME(CHAN,NULL,'000,FLG);
RELEASE(CHAN);
READ(CHAN←-1,0,BRCHAR,EOF,TMPFILE,"INF");
RENAME(CHAN,BASFIL,'055,FLG);
RELEASE(CHAN);
ENDC
END "DOUTBAS";
! Procedure too output a list of rand regions without destroying
their original props when the procedure is done;
simple internal PROCEDURE DNEWBAS(REFERENCE STRING BASFIL;REFERENCE LIST REGLST);
BEGIN "DNEWBAS"
DOUTBAS(BASFIL,REGLST);
END "DNEWBAS";
! Procedure to copy region number CREG from an asci file into CURREG;
simple internal PROCEDURE DCOPBAS(REFERENCE STRING BASFIL; REFERENCE STRING ITEMVAR CURREG; INTEGER CREG);
BEGIN "DCOPBAS"
PRINT("THIS ROUTINE WAS REMOVED FOR LACK OF USE",CRLF);
END "DCOPBAS";
! Procedure to delete a data base from core;
simple internal PROCEDURE DELBAS(REFERENCE LIST REGLST);
BEGIN "DELBAS"
INTEGER ITMNUM;
! Remember number of items in use before DELBAS;
ITMNUM←DITEMS;
! Delete all the regions now;
WHILE(LENGTH(REGLST)) DO
BEGIN
DREG(LOP(REGLST));
PRINT("@");
END;
PRINT(CRLF);
PRINT(ITMNUM-DITEMS," Items released",crlf);
END "DELBAS";
simple internal PROCEDURE DRELFIL(STRING FILE);
BEGIN
INTEGER CHAN,FLG;
STRING DEV;
DEV←GETDEV(FILE,NULL);
IFCR TENEX THENC
IF CHAN←OPENFILE(FILE,"AE") >0 THEN BEGIN
CLOSF(CHAN);
DELF(CHAN);
CFILE(CHAN);
END;
ELSEC
OPEN(CHAN←DGETCHAN,DEV,'0,4,0,0,0,0);
LOOKUP(CHAN,FILE,FLG);
IF ¬FLG THEN RENAME(CHAN,NULL,0,FLG)
ELSE PRINT("DATBAS: Can't find ",FILE," so it can't be deleted by me",crlf);
RELEASE(chan);
ENDC
end;
REQUIRE UNSTACK!DELIMITERS;
END "DATBAS";